home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / subs.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  23.3 KB  |  949 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # This file contains misc. routines that probably belong somewhere else
  8.  
  9. # update the scroll region of a frame's containing canvas
  10. # This should be called every time the frame changes size
  11. # there should be a separate one of these for forms
  12.  
  13. if {$P(center)} {
  14.     proc scrollregion_update {frame} {
  15.         set canvas [winfo parent $frame]
  16.         set fw  [winfo reqwidth $frame ]
  17.         set fh [winfo reqheight $frame]
  18.         set cw [winfo width $canvas]
  19.         set ch [winfo height $canvas]
  20.  
  21.         set x1 [expr ($fw - $cw)/2]
  22.         set x2 [expr $x1 + $cw]
  23.         set y1 [expr ($fh - $ch)/2]
  24.         set y2 [expr $y1 + $ch]
  25.         foreach i "$canvas ${canvas}_row ${canvas}_column" {
  26.             catch {$i configure -scrollregion "$x1 $y1 $x2 $y2"}
  27.         }
  28.     }
  29. } else {
  30.     proc scrollregion_update {frame} {
  31.         set canvas [winfo parent $frame]
  32.         set width  [winfo reqwidth $frame ]
  33.         set height [winfo reqheight $frame]
  34.         foreach i "$canvas ${canvas}_row ${canvas}_column" {
  35.             catch {$i configure -scrollregion "0 0 $width $height"}
  36.         }
  37.     }
  38. }
  39.  
  40. # update table geometry
  41. # This should be call anytime the geometry of the table changes
  42. # Its slow, so try not to do this too often
  43. # parent: The "master" of the widgets
  44.  
  45. # Schedule an update to happen later
  46.  
  47. proc update_table {master {why "?"}} {
  48.     global Update_Scheduled
  49.     if {![info exists Update_Scheduled]} {
  50.         dputs $master
  51.         after idle "do_update_table"
  52.     }
  53.     dputs $master ($why)
  54.     set Update_Scheduled($master) 1
  55. }
  56.  
  57. # do all scheduled updates
  58.  
  59. proc do_update_table {} {
  60.     global Update_Scheduled
  61.     # outline_forget
  62.     set list [array names Update_Scheduled]
  63.     dputs <$list>
  64.     foreach master $list {
  65.         table_setup $master
  66.         arrow_update .can $master
  67.         outline_update $master
  68.     }
  69.     scrollregion_update .can.f
  70.     catch {unset Update_Scheduled}
  71. }
  72.  
  73. # run a command later, but not if already scheduled
  74.  
  75. proc when_idle {cmd {when idle}} {
  76.     after cancel $cmd
  77.     after $when $cmd
  78. }
  79.  
  80. # update the b-search routines
  81. #   master:  The list of masters to update
  82. # obsolete
  83.  
  84. proc update_bsearch {master} {
  85.     dputs "Bsearch: $master"
  86.     foreach i $master {
  87.         upvar #0 geom:$i data
  88.         eval [gen_bsearch get_col_$i $data(column_coords) -1]
  89.         eval [gen_bsearch get_row_$i $data(row_coords) -1]
  90.     }
  91. }
  92.  
  93. # clone a widget for interactive placement (just geometry)
  94.  
  95. proc clone_widget {old new} {
  96.     lappend cmd [string tolower [winfo class $old]] $new
  97.         foreach option [$old configure] {
  98.         if {[llength $option] != 5}  continue
  99.         if {[string compare [lindex $option 3] [lindex $option 4]] ==0} continue
  100.         lappend cmd [lindex $option 0] [lindex $option 4]
  101.     }
  102.     catch "destroy $new"
  103.     dputs  $old -> $new
  104.     eval $cmd
  105. }
  106.  
  107. # just a little !PC
  108.  
  109. proc choose_insult {} {
  110.     set insults {
  111.         dummy moron idiot numbskull dweeb twit sped geek nerd
  112.     }
  113.     return [lindex $insults [expr [info cmdcount] % [llength $insults]]]
  114. }
  115.  
  116. # unselect the current widget, removing the option box if any
  117. # might as well get rid of the resize-handles, if any, and extra outline box
  118.  
  119. proc unselect_widget {} {
  120.     global Current Geometry
  121.     if {[set current $Current(widget)] != ""} {
  122.         dputs $current
  123.         set Current(widget) {}
  124.         set Current(form) {}
  125.         set Current(text) {}
  126.         if {[winfo ismapped .widget]} {
  127.             set Geometry(widget) [wm geometry .widget]
  128.             wm withdraw .widget
  129.         }
  130.         # this doesn't belong here!
  131.         .entry configure -state disabled
  132.         # undo the highlighting
  133.         set name [winfo name $current]
  134.         window_unhighlight $current
  135.         # this will remove a superfluous outline
  136.         global $name
  137.         outline_trace $name
  138.         del_resize_handles ${current}_outline
  139.     }
  140. }
  141.  
  142. # make an option entry form, make it tough to destroy
  143. # this will be expanded later.  Make sure its OK for the user to destroy
  144. # The window
  145.  
  146. proc build_option_form {form {event 0}} {
  147.     if {$event} {
  148.         global Current
  149.         window_unhighlight $Current(sample) palette
  150.         set Current(sample) {}
  151.     }
  152.     if {[winfo exists $form]} {
  153.         bind $form <Destroy> {}
  154.         destroy $form
  155.     }
  156.     toplevel $form
  157.     label $form.msg -width 40
  158.     frame $form.form -highlightthickness 0
  159.     blt_table $form $form.form 0,0 -fill both
  160.     blt_table $form $form.msg 1,0 -fill none
  161.     blt_table row $form configure 0 -resize both
  162.     blt_table row $form configure 1 -resize none
  163.     blt_table column $form configure 0 -resize both
  164.     wm withdraw $form
  165.     bind $form <Destroy> {
  166.         if {[winfo class %W] == "Toplevel" } {
  167.             after idle "build_option_form %W 1"
  168.         }
  169.     }
  170. }
  171.  
  172. # don't put the following items into forms
  173. # this doesn't really belong here
  174.  
  175. proc ignore_items {} {
  176.     global Widget_data
  177.     array set Widget_data {
  178.         ignore:type    {}
  179.         ignore:pathname    {}
  180.         ignore:error    {}
  181.         ignore:focus    {}
  182.         ignore:level    {}
  183.         ignore:master    {}
  184.         ignore:resize_row    {}
  185.         ignore:resize_column    {}
  186.         ignore:min_row    {}
  187.         ignore:min_column    {}
  188.         ignore:reqwidth    {}
  189.         ignore:reqheight    {}
  190.     }
  191. }
  192.  
  193. # update the current form (if any) given a new widget value
  194. # This belongs in the forms package.
  195.  
  196. proc sync_form {field value} {
  197.     global Widget_data _Message Current
  198.  
  199.     dputs $field $value
  200.     if {[set win $Current(widget)] == ""} {return 0}
  201.     set Current(dirty) 1
  202.     upvar #0 [winfo name $win] data
  203.     if {[info exists data($field)]} {
  204.         set data($field) $value
  205.         dputs "Setting [winfo name $win] $field <- $value"
  206.     }
  207.  
  208.     # update the entry form (if it exists)
  209.  
  210.     set entry .widget.form.can.f.[winfo name $win],${field},entry
  211.     dputs "updating $entry ($field := $value)"
  212.     if {$Current(form) == $win  && [winfo exists $entry]} {
  213.         if {[info exists Widget_data(infilter:$field)]} {
  214.             if {![$Widget_data(infilter:$field) value]} {
  215.                 set _Message $value
  216.                 return 0
  217.             }
  218.         }
  219.         $entry delete 0 end
  220.         $entry insert 0 $value
  221.     }
  222.     return 1
  223. }
  224.  
  225. # keyboard short cuts for text entry - just testing
  226. # Automatically select a different widget
  227. # - If no widget is selected, select 1st widget in current frame
  228. # - If a widget is selected, select next widget in current frame
  229.  
  230. proc short_cut {what} {
  231.     global Current Widgets
  232.     set widget $Current(widget)
  233.     upvar #0 geom:$Current(frame) data
  234.  
  235.     set widgets [blt_table slaves $Current(frame) -match *#* -exclude *@*]
  236.     dputs $widgets
  237.     if {[llength $widgets] < 1 } return 
  238.     if {[llength $widgets] < 2 && $Current(widget) != ""} return 
  239.     switch -glob $what {
  240.         *Right {set opt increasing}
  241.         *Left {set opt decreasing}
  242.     }
  243.     set sorted [lsort -$opt -command "sort_widgets" $widgets]
  244.     dputs $sorted
  245.  
  246.     # loop through list to next widget which isn't me
  247.  
  248.     set me 0
  249.     foreach i "$sorted [lindex $sorted 0]" {
  250.         if {$widget != $i} {
  251.             if {$me} break continue        ;# I couldn't resist
  252.         } else {incr me}
  253.     }
  254.     unselect_widget
  255.     select_widget $i
  256.     focus .entry
  257.     update idletasks
  258. }
  259.  
  260. # sort some widgets either by increasing rows or columns
  261. # we should cache this information
  262.  
  263. proc sort_widgets {win1 win2} {
  264.     scan [blt_table info $win1] "%*s %d,%d" r1 c1
  265.     scan [blt_table info $win2] "%*s %d,%d" r2 c2
  266.     #puts "$r1,$c1  $r2,$c2"
  267.     return [expr {($r1*1000 + $c1) - ($r2*1000 + $c2)}]
  268. }
  269.  
  270. # save, compile and run!
  271. # save to a different file name, and preserve the dirty bit
  272. # the file management is poor, and needs fixing
  273.  
  274. set Current(Test_app) ""
  275. proc build_app {name {wish wish4.1}} {
  276.     global _Message Widgets Current P
  277.     if {![info exists Widgets]} {
  278.         set _Message "Nothing to build"
  279.         return
  280.     }
  281.  
  282.     # compute frame stacking and tabbing order
  283.     global f; set f(level) 0
  284.     set_frame_level .can.f
  285.     
  286.     set dirty $Current(dirty)
  287.     set name [file root $Current(project)]
  288.     set file STest[pid]
  289.     save_project $file.ui
  290.     exec touch $file.ui
  291.     compile $file.ui $file.ui.tcl $name
  292.     set _Message "Starting test application"
  293.     set Current(project) $name
  294.     set Current(dirty) $dirty
  295.     set_title $name
  296.     update idletasks
  297.  
  298.     set tmp /tmp/ST[pid].tcl
  299.     set fd [open $tmp w]
  300.     set Current(test_app) test_$name
  301.     puts $fd "tk appname \"test_$name\""
  302.     puts $fd "wm title .  \"SpecTcl - $name\""
  303.     puts $fd "source \"[pwd]/$file.ui.tcl\""
  304.     if {[file readable $name.tcl]} {
  305.         puts $fd "source \"[pwd]/$name.tcl\""
  306.     } else {
  307.         puts $fd "\"${name}_ui\" ."
  308.     }
  309.     close $fd
  310.     catch {send test_$name "after 1 {exit 0}"}
  311.     exec $wish $tmp &
  312.  
  313.     # we should remove the temp files carefully
  314.  
  315.     after 2000 "exec rm -f $file.ui.tcl $file.ui"
  316. }
  317.  
  318. # remove all outline traces - reset application
  319.  
  320. proc reset_outlines {{name {}}} {
  321.     global Widgets Current
  322.     if {$name == "" && [array exists Widgets]} {
  323.         set list [array names Widgets]
  324.     } else {
  325.         set list $name
  326.     }
  327.     foreach i $list {
  328.         trace vdelete ${i}(geometry:rowspan) w  outline_trace
  329.         trace vdelete ${i}(geometry:columnspan) w  outline_trace
  330.     }
  331. }
  332.  
  333. ######## Stuff added to support row/column indicators
  334.  
  335. # scroll multiple canvii with a single scroll bar
  336. #   list:        The list of canvii to scroll
  337. #   how:        "x" or "y"
  338. #   args:        The rest
  339.  
  340. proc can_view {list how args} {
  341.     foreach canvas $list {
  342.         eval "$canvas ${how}view $args"
  343.     }
  344. }
  345.  
  346. # extract info about a row or column of the table geometry manager
  347. # There's no easy way
  348. #  master:  The table "master"
  349. #  type:    "row" or "column"
  350. #  index:   the column or row number
  351. #  array:   Where to place the results
  352.  
  353. proc extract_geom {master type index array} {
  354.     upvar $array data
  355.     set config [blt_table $type $master configure $index]
  356.     set data(pad)    [lindex [lindex $config 0] 4]
  357.     set data(resize) [lindex [lindex $config 1] 4]
  358.     set dim    [lindex [lindex $config 2] 4]
  359.     set data(min)    [lindex $dim 0]
  360.     set data(max)    [lindex $dim 1]
  361.     return ""
  362. }
  363.  
  364. # put it back
  365.  
  366. proc insert_geom {master type index array} {
  367.     global P
  368.     upvar $array data
  369.  
  370.     if {$data(min) < $P(grid_size)} {
  371.         set min $P(grid_size)
  372.     } else {
  373.         set min $data(min)
  374.     }
  375.  
  376.     blt_table $type $master configure $index \
  377.         -padx $data(pad) \
  378.         -resize $data(resize) \
  379.         -width "$min $data(max)"
  380. }
  381.  
  382. # this is just a place holder for now - should be a menu
  383. # this should be obsolete
  384.  
  385. proc next_text_style {win} {
  386.     global Current _Message
  387.     set styles {"" Bold Italic Bold,Italic}
  388.     if {[set widget $Current(widget)] == ""} {return}
  389.  
  390.     # extract the font components from the widget
  391.     if {[catch {set font [$widget cget -font]}]} {
  392.         set _Message "Font style not available for [winfo class $widget]"
  393.         return
  394.     }
  395.     InFilter_font font
  396.     regexp {([^,]*,[^,]*),*(.*)} $font dummy base style
  397.  
  398.     # go to next style
  399.  
  400.     set current [lsearch $styles $style]
  401.     if {[incr current] >= [llength $styles]} {set current 0}
  402.     set font $base,[lindex $styles $current]
  403.  
  404.     # convert and set back new style
  405.  
  406.     if {![OutFilter_font dummy font font]} {
  407.         set _Message $font
  408.         return
  409.     }
  410.     catch "$widget configure -font $font"
  411.  
  412.     # now update the style of the template
  413.  
  414.     set font [$win cget -font]
  415.     InFilter_font font
  416.     regexp {([^,]*,[^,]*),*(.*)} $font dummy base style
  417.     set font $base,[lindex $styles $current]
  418.     OutFilter_font dummy font font
  419.     sync_form font $font
  420.     catch "$win configure -font $font"
  421. }
  422.  
  423. # choose the next text-style for the current widget
  424.  
  425. set Fontstyle ""
  426. proc setup_style {win name {command puts}} {
  427.     global Fontstyle
  428.     menubutton $win -menu $win.style -width 2 \
  429.         -textvariable $name -bd 2 -relief ridge -padx 1 -pady 1
  430.     menu $win.style
  431.     set font [$win.style cget -font]
  432.     InFilter_font font
  433.     regexp {([^,]*,[^,]*),*(.*)} $font dummy base style
  434.     foreach style {"" Bold Italic Bold,Italic} {
  435.         set font $base,$style
  436.         OutFilter_font dummy font font
  437.         $win.style add command -label A -font $font -command "
  438.                 set $name $style
  439.                 eval \"$command $item\"
  440.             "
  441.     }
  442. }
  443.  
  444. # Delete whatever is currently selected
  445.  
  446. proc delete_selected {{arrows 1}} {
  447.     global Current _Message
  448.     undo_mark
  449.     if {[set die $Current(widget)] != ""} {
  450.         delete_selected_widget $die
  451.     } elseif {$arrows} {                ;# try to delete selected row or column
  452.         delete_selected_arrow
  453.     }
  454.     update_table .can.f delete_widget
  455. }
  456.  
  457. # delete the currently selected widget
  458.  
  459. proc delete_selected_widget {die} {
  460.     global Current _Message Widgets Frames P
  461.  
  462.     unselect_widget
  463.     set name [winfo name $die]
  464.     reset_outlines $name
  465.     catch "destroy ${die}_outline"
  466.  
  467.     # destroy all widgets packed inside
  468.  
  469.     if {[info exists Frames($die)]} {
  470.         undo_log delete_frame [winfo name $die] [grid_size $die]
  471.         grid_destroy $die        ;# only needed if we don't destroy the widget
  472.         foreach i [blt_table slaves $die] {
  473.             delete_selected_widget $i
  474.         }
  475.         unset Frames($die)
  476.     } else {
  477.         undo_log delete_widget $name
  478.     }
  479.  
  480.     # blt_table forget $die        ;# redundant with destroy
  481.     destroy $die
  482.     unset Widgets($name)
  483.     # reset grid spacing if row/col becomes empty
  484.     grid_spacing $Current(frame)     ;# lazy!
  485.     set Current(widget) {}
  486. }
  487.  
  488. # delete the currently selected row and/or column BROKEN!
  489.  
  490. proc delete_selected_arrow {} {
  491.     global Current _Message
  492.     foreach i {row column} {
  493.         if {[set tag $Current($i)] != ""} {
  494.             regexp {tag:([^_]*)_(.*)} $tag dummy master index
  495.             dputs "creating arrow $master $i $index"
  496.             if {![table_delete $master $i $index]} {
  497.                 set _Message "can't delete non-empty $i"
  498.             } elseif {[grid_remove $master $i]} {
  499.                 grid_update $master
  500.                 set tag [arrow_delete .can $i $master]
  501.                 if {$Current($i) == $tag} {
  502.                     dputs "Unselecting dead $i arrow $tag"
  503.                     set Current($i) ""
  504.                 }
  505.             }
  506.         }
  507.     }
  508. }
  509.  
  510. # display progress of widget initialization
  511.  
  512. proc widget_progress {name} {
  513.     global _Message
  514.     set _Message "locating all widgets: $name"
  515.     update idletasks
  516. }
  517.  
  518. # temporary test mode (broken)
  519.  
  520. proc test_mode {} {
  521.     global P _Message Test_mode Grid Was_grid
  522.     if {$Test_mode} {
  523.         set _Message "entering test mode"
  524.         unselect_widget
  525.         button_undo widget $P(button)
  526.         button_undo sub_widget $P(button)
  527.         set Was_grid 0
  528.         if {$Grid != 0} {
  529.             .buttons.grid invoke
  530.             set Was_grid 1
  531.         }
  532.         grid_spacing .can.f 0
  533.     } else {
  534.         set _Message "entering edit mode"
  535.         grid_spacing .can.f $P(grid_spacing)
  536.         button_setup . widget widget $P(button) $P(gravity)
  537.         if {$Was_grid} {
  538.             .buttons.grid invoke
  539.         }
  540.         # for sub-frames
  541.         button_setup . sub_widget widget $P(button) $P(gravity) \
  542.             {[winfo parent %W] %X %Y}
  543.     }
  544. }
  545.  
  546. # place holder
  547.  
  548. proc frame_configure {win} {
  549.     dputs "Calling frame configure"
  550. }
  551.  
  552.  
  553. # choose black, except when it won't show, then white
  554.  
  555. proc contrast_color {color} {
  556.     set rgb  [winfo rgb . $color]
  557.     set y [expr {
  558.         [lindex $rgb 0]*0.6 + [lindex $rgb 1]*0.3 + [lindex $rgb 2]*0.1
  559.         }]
  560.     return [expr {$y > 1000 ? "black" : "white"}]
  561. }
  562. # choose black, except when it won't show, then white
  563.  
  564. proc Contrast_color {color} {
  565.     set result #
  566.     foreach  i [winfo rgb . $color] {
  567.         if {$i > 32768 } {append result 0} {append result F}
  568.     }
  569.     return $result
  570. }
  571.  
  572. proc current_frame {frame} {
  573.     global Frames Current P
  574.     dputs $frame ? $Current(frame)
  575.     if {$frame == $Current(frame)} return
  576.     set Current(frame) $frame
  577.     # do_update_table $frame switch-frame    ;# doesn't belong here!
  578.     arrow_unhighlight row
  579.     arrow_unhighlight column
  580.     arrow_activate .can $frame        ;# temporary?
  581.  
  582.     # fix up the grid colors
  583.  
  584.     foreach i [array names Frames] {
  585.         set current [$i cget -bg]
  586.         if {$i == $frame} {
  587.             grid_color $i [Contrast_color $current]
  588.         } else {
  589.             grid_color $i $current
  590.         }
  591.     }
  592. }
  593.  
  594. # We'll keep track of this our selves
  595.  
  596. proc find_master {win} {
  597.     upvar #0 [winfo name $win] data
  598.     return $data(master)
  599. }
  600.  
  601. # set the master window for this widget
  602. # We'll keep it in the widgets configuration array
  603. #  widget:  The widget name
  604. #  master:    The frame its packed in
  605.  
  606. proc set_master {widget master} {
  607.     upvar #0 [winfo name $widget] data
  608.     dputs "set_master: $widget $master"
  609.     regsub {^\.can\.f} $master {} data(master)
  610. }
  611.  
  612. # compute the nesting depth of frames, so their stacking order is
  613. # generated correctly.  Store result in the "level" entry of the widget
  614. # structure
  615.  
  616. proc set_frame_level {master {level 0}} {
  617.     incr level
  618.     set exclude "@"
  619.     regexp {frame#[0-9]+} $master exclude
  620.     dputs "setting level $level for $master (exclude $exclude)"
  621.     foreach frame [blt_table slaves $master -exclude *${exclude}* -match *frame#*] {
  622.         upvar #0 [winfo name $frame] data
  623.         set data(level) $level
  624.         set_frame_level $frame $level
  625.         dputs "level: $frame = $level"
  626.     }
  627. }
  628.  
  629. # compute a widgets nominal position, which is the top left corner
  630. # of its enclosing cell
  631.  
  632. proc get_tabbing_coords {win} {
  633.     upvar #0 [winfo name $win] data
  634.     upvar #0 geom:.can.f$data(master) geom
  635.     scan [blt_table info $win] "%s %d,%d" dummy row col
  636.     set x [expr [winfo x .can.f$data(master)] + $geom(column_$col)]
  637.     set y [expr [winfo y .can.f$data(master)] + $geom(row_$row)]
  638.     dputs "$win: (master $data(master)) $row,$col -> $x,$y"
  639.     return "$y $x"
  640. }
  641.  
  642. # figure out which sub-grid we're sitting on
  643. #   x,y:   Where we're at (%X, %Y)
  644. #   skip: never decend into this level
  645. #   start: where in the grid to start (used internally to manage recursion)
  646.  
  647. proc find_grid {x y {skip ""} {start ".can.f"}} {
  648.     global Frames
  649.  
  650.     # don't desend onto self
  651.  
  652.     if {$start == $skip} {
  653.         dputs "Skipping SELF $start"
  654.         return $start
  655.     }
  656.  
  657.     upvar #0 geom:$start data
  658.     set row [blt_table row $start location "$y - [winfo rooty $start]"]
  659.     set column [blt_table column $start location "$x - [winfo rootx $start]"]
  660.     set owner [blt_table slaves $start -column $column -row $row]
  661.     if {[info exists Frames($owner)]} {
  662.         set start [find_grid $x $y $skip $owner]
  663.     }
  664.     return $start
  665. }
  666.  
  667. # describe a widget briefly
  668.  
  669. proc widget_describe {win} {
  670.     upvar #0 [winfo name $win] data
  671.  
  672.     set text "?"
  673.     set class $data(type)
  674.     if {[info exists data(text)]} {
  675.         set text $data(text)
  676.     } elseif {[info exists data(label)]} {
  677.         set text $data(label) 
  678.     } else {
  679.         set text $data(item_name)
  680.         set try [split $text #]
  681.         if {[llength $try] > 1} {
  682.             set text [lindex $try end]
  683.         }
  684.     }
  685.     regsub -all "\n" $text / text
  686.     set text [string range $text 0 [string length $class]]
  687.     if {$text == $class} {
  688.         return $class
  689.     } else {
  690.         return "$class\n$text"
  691.     }
  692. }
  693.  
  694. # see if a configuration change to a widget requires a table update
  695. # name:    The name of the window that got a configure event
  696. # This still forces updates even when none are needed
  697.  
  698. proc check_update {name} {
  699.     upvar #0 [winfo name $name] data
  700.     set need_update 0
  701.     set width [winfo width $name]
  702.     set height [winfo height $name]
  703.     if {[catch {set change [expr $width != $data(pixel_width) || \
  704.             $height != $data(pixel_height)]}] || $change} {
  705.         set data(pixel_width) $width
  706.         set data(pixel_height) $height
  707.         update_table .can.f$data(master) "configure $data(master) $name"
  708.     }
  709. }
  710.  
  711. # A simpler version
  712.  
  713. proc check_update {name} {
  714.     upvar #0 [winfo name $name] data
  715.     update_table .can.f$data(master) "configure$name"
  716. }
  717.  
  718. # adjust the resize behavior of the row or col if its the first one
  719. # add in the widget, making sure to get the resize behavior right
  720. #  master: the table to adjust
  721. #  widget: The widget I'm about to add
  722. #  row,col: Where its about to go
  723.  
  724. proc table_enter {master widget row col} {
  725.     global P
  726.     upvar #0 geom:$master data
  727.     blt_table $master $widget $row,$col
  728. }
  729.  
  730. # This is an experiment to use the window to be moved as its cursor!
  731.  
  732. # grab an image of a window, to turn into a cursor
  733.  
  734. proc make_cursor_from_window {{win .}} {
  735.     set file /tmp/$win.[pid]
  736.     set dither mdither
  737.     set data [exec xgrabsc -id [winfo id $win] -nobell -noborders -$dither -bm]
  738.     regsub {x_hot 0} $data "x_hot [expr [winfo width $win]/2]" data
  739.     regsub {y_hot 0} $data "y_hot [expr [winfo height $win]/2]" data
  740.     set fd [open $file w]
  741.     dputs $fd $data
  742.     close $fd
  743.     return $file
  744. }
  745.  
  746. # set the cursor to look like the window its on!
  747.  
  748. proc set_cursor {win {color black}} {
  749.     global Cursor_save
  750.     set Cursor_save($win) [$win cget -cursor]
  751.     dputs "SAVING $win"
  752.     $win configure -cursor watch
  753.     update idletasks
  754.     $win configure -cursor "@[make_cursor_from_window $win] $color"
  755. }
  756.  
  757. proc unset_cursor {} {
  758.     global Cursor_save
  759.     parray Cursor_save
  760.     set win [array names Cursor_save]
  761.     $win configure -cursor $Cursor_save($win)
  762.     unset Cursor_save
  763.     after idle "exec rm -f /tmp/$win.[pid]"
  764. }
  765.  
  766. # extract/insert blt_table options into an array
  767. # convert row and column to behave!
  768.  
  769. proc blt_get {win array} {
  770.     upvar $array data
  771.     array set data [blt_table info $win]
  772.     set tmp [split $data($win) ,]
  773.     array set data "-row [lindex $tmp 0] -column [lindex $tmp 1]"
  774.     unset data($win)
  775.     unset data(-reqheight) data(-reqwidth)        ;# we don't use these for now
  776. }
  777.  
  778. proc blt_set {table win array} {
  779.     upvar $array data
  780.     set geom $data(-row),$data(-column)
  781.     unset data(-row) data(-column)
  782.     return "blt_table $table $win $geom [array get data -*]"
  783. }
  784.  
  785. # snagged from the net
  786.  
  787. set RNseed [pid]
  788. proc random {} {
  789.     global RNseed
  790.     set RNseed [expr 30903*($RNseed&65535)+($RNseed>>16)]
  791.     return [expr ($RNseed & 65535)/65535.0]
  792. }
  793.  
  794. # insert a binding tag into a window
  795.  
  796. proc insert_tag {win tag} {
  797.     set tags [bindtags $win]
  798.     if {[lsearch -exact $tags $tag] != -1} {
  799.         return 0        ;# tag is already there
  800.     }
  801.     bindtags $win "$tag $tags"
  802.     return 1
  803. }
  804.  
  805. # delete a tag from a tag binding.
  806.  
  807. proc delete_tag {win tag} {
  808.     set tags [bindtags $win]
  809.     if {[set index [lsearch -exact $tags $tag]] == -1} {
  810.         return 0        ;# tag is not there
  811.     } else {
  812.         bindtags $win [lreplace $tags $index $index]
  813.     }
  814.     return 1
  815. }
  816.  
  817. # temporary procedure to edit code
  818.  
  819. set Clip ""
  820. proc edit_code {{name untitled}} {
  821.     catch "destroy .edit"
  822.     toplevel .edit
  823.     wm title .edit "$name Code"
  824.     edit_ui .edit
  825. }
  826.  
  827.  
  828. # clear out everyhing (less drastic than reset)
  829.  
  830. proc clear_all {{restart 1}} {
  831.     global Widgets Current Frames Next_widget argv P f
  832.  
  833.     # pop up dialog if dirty bit is set
  834.     if {$Current(dirty) != ""} {
  835.         set msg "$Current(project) has not been saved"
  836.         switch [tk_dialog .sure Warning  $msg "questhead" \
  837.                 0 Cancel "Save $Current(project)" "Discard changes"] {
  838.             0 {return 0}
  839.             1 {save_project  $Current(project).$P(file_suffix) 1}
  840.         }
  841.     }
  842.     set Current(dirty) ""
  843.  
  844.     foreach i [array names Widgets] {
  845.         global $i
  846.         catch "unset $i"
  847.     }
  848.     set argv ""
  849.     catch {unset Frames}
  850.     catch {unset Undo_log}
  851.     undo_reset
  852.     eval "destroy [winfo children .can.f] .widget .generic"
  853.     arrow_zapall .can
  854.     foreach i [array names Next_widget] {
  855.         set Next_widget($i) 0
  856.     }
  857.     foreach i [array names Current] {
  858.         set Current($i) ""
  859.     }
  860.     catch {unset Widgets}
  861.     catch {unset f}
  862.  
  863.     if {!$restart} return
  864.  
  865.     # reinitilize main
  866.     # This is overkill, but play it safe for now
  867.  
  868.     set parent .can.f
  869.     frame $parent.marker            ;# stacking order marker - below all buttons
  870.     set Current(frame) $parent
  871.     set Current(project) $P(project)
  872.     set_title $Current(project)
  873.     set Frames($parent) 1
  874.     current_frame $parent 
  875.  
  876.     widget_extract .can.f
  877.     set_master .can.f .can.f
  878.     set f(type) frame
  879.     grid_create .can.f $P(maxrows) $P(maxcols) $P(grid_size) $P(grid_color)
  880.     table_setup $parent
  881.     arrow_zapall .can
  882.     arrow_create .can_row row .can.f all
  883.     arrow_create .can_column column .can.f all
  884.     arrow_activate .can $parent $P(grid_color)
  885.     return 1
  886. }
  887.  
  888. # short cut for accessing fields in property sheet (temporary)
  889. # look for fields of the form: .widget.form.can.f.<widget>,key*,entry  
  890. # If a field is in the map, go to it, else go to the 1st with letter
  891.  
  892. array set Access_map {
  893.     t textvariable
  894.     c command
  895.     v variable
  896.     i item_name
  897.     w width
  898. }
  899.  
  900. # wrong! need to check config array instead!
  901. # short cut for popping up option sheets.  Call the tk menu traversal
  902. # code explicitly if the key is not relevent
  903.  
  904. proc access_field {key} {
  905.     global Current _Message Access_map
  906.     if {[set win $Current(widget)] == ""} {
  907.         return 0
  908.     }
  909.  
  910.     catch {set key $Access_map($key)}
  911.     upvar #0 [winfo name $win] data
  912.     set field [lindex [lsort [array names data $key*]] 0]
  913.     dputs "accessing <$key> ($field)"
  914.     if {$field == ""} {
  915.         return 0
  916.     }
  917.     eval widget_up $win 0 0 .widget.form.can.f.[winfo name $win],$field,entry
  918.     raise .widget
  919.     return 1
  920. }
  921.  
  922. # Quit with dialog
  923.  
  924. proc quit {{cancel 1}} {
  925.     if {![catch {glob /tmp/*[pid].tcl} result]} {
  926.         eval exec "rm -f $result"    ;# need to put somewhere
  927.     }
  928.     set buttons {really\nquit "Save\n& quit"}
  929.     if {$cancel} {
  930.         lappend buttons Cancel\n
  931.     }
  932.     global Current P
  933.     if {$Current(dirty) == ""} exit
  934.     set message "There are unsaved changes\nare you sure?"
  935.     switch [eval tk_dialog .quit quit \$message questhead 0 $buttons] {
  936.         0 exit
  937.         1 {save_project  $Current(project).$P(file_suffix) 1; exit}
  938.     }
  939. }
  940.  
  941.  
  942. # set the window and icon title
  943.  
  944. proc set_title {name} {
  945.     global P
  946.     wm iconname . $name
  947.     wm title . "$P(title) - $name"
  948. }
  949.